２９．各種処理例
本項はExcel2000で作成したマクロ例を記述するが、各バ−ジョン実行可不可は下記マ−クで示す。
●●● Excel95可 ・Excel97可 ・Excel2000可
○●● Excel95不可・Excel97可 ・Excel2000可
○○● Excel95不可・Excel97不可・Excel2000可
(上記のごとく、○が実行不可）
２９−１．HTMLファイルをワ−クシ−トへ表示
私の場合HTMLファイルは、Excelのワ−クシ−トに書いた複雑な表は自分で作った
「KI_Web」で変換するがそれ以外は、HTMLタグを必要に応じ入れながら通常の
テキスト文としてスラスラ書いていく。但しスラスラ書くのはよいが間違いも
あるようで、６月始めよりExcel97のコ−ナ−を作り始めたが「Explorer」で
は表示出来たが「Netscape」で表示出来ないペ−ジがあった。そんなトラブルを
無くす為に簡単なHTMLタグのチェックマクロを作成した。
●●○下記マクロで、HTMLソ−スをワ−クシ−トへ表示できます。詳細ソ−スは
KI_htmlchHTML文章チェック(開始・終了タグ確認)
にあります。
Sub 例291()
Const phn1 As String = "c:\windows\temp" '仮の保存場所
'ダイアログ表示
fff = Application.GetOpenFilename(Title:="HTMLタグをチェックするファイル指定")
If fff = "False" Then
MsgBox "ファイルを１個指定して下さい"
Exit Sub
End If
'拡張子
i = 0
i = InStr(1, fff, ".", 1)
If i > 0 Then
ext = Mid(fff, i + 1)
End If
If InStr(1, ext, "htm", 1) = 0 Then
MsgBox "拡張子「html」or「htm」以外は指定出来ません"
Exit Sub
End If
FileCopy fff, phn1 & "\htmlcheck.csv"
Workbooks.Open FileName:=phn1 & "\htmlcheck.csv"
End Sub
・Excel95では、拡張子.html又は.txt（HTMLタグの記述あり）のどちらでも
開けシ−トへ表示できたが、Excel97では２種類とも開けない（ソ−スを
表示したいのに勝手にWebと同じ表示になる）ので、拡張子を強制的に
csvにしたらソ−スを表示できた。
・Excel2000では、csvファイルでもソ−スを取り込めない(29-19へ別な方法を追加）
・"c:\windows\temp" をcsv仮の保存場所にしてあるがシステムに合わせ変更のこと。
２９−２．特定文字を色付け
●●●下記マクロは１行の文字の中に、変数"su"に入っている文字と同じ
文字があった場合その文字を赤色にしたケ-ス。
Sub 例292()
su = Len(tag(c))
For j = 1 To cen2
ssa = 0: ssb = 0
dat = Cells(j, 1)
Do
ssa = InStr(1, dat, tag(c), 1)
If ssa > 0 Then
ssb = ssb + ssa
dat = Mid(dat, ssa + 1)
Cells(j, 1).Select
ActiveCell.Characters(Start:=ssb, Length:=su) _
.Font.ColorIndex = 3
Else
Exit Do
End If
Loop Until ssa = 0
Next
End Sub
・変数"cen2は最終セル値で事前に取得のこと。
２９−３．表示されているセルのみコピ−
○●●表1のデ−タから"-A""-C"以外を非表示にすると表2となる。
さらに表示されているセルのみコピ−すると表３となる。
Sub 例293()
ActiveCell.SpecialCells(xlLastCell).Select
cend = ActiveCell.Row
’指定以外を非表示
For i = 2 To cend
If InStr(1, Cells(i, 1), "-A", 1) > 0 Then
GoTo pas1
ElseIf InStr(1, Cells(i, 1), "-C", 1) > 0 Then
GoTo pas1
Else
Rows(i).EntireRow.Hidden = True
End If
pas1:
Next
'表示行選択
Range(Cells(1, 1), Cells(cend, 15)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
'シ−ト"mySheetA"を追加しそこに貼り付け
Sheets.Add.Name = "mySheetA"
ActiveSheet.Paste
Range("C1").Select
End Sub
★本例はExcel95は動作不可ですが、(xlCellTypeVisible)→(xlVisible)に変えれば動作ＯＫ
参考２９-１ 行削除実行の注意点
・Excel95で２秒以下だった行削除(参292と類似もの)のマクロを、Excel97で
実行したら10倍以上の２５秒ほど掛かり余り遅いのでスタックと思い焦ってしまった。
・原因は、参291()のようなプリンタ−設定のマクロを実行すると、対象シ−トは97で
はDisplayPageBreaが"True"に変わる(下図の参照)。その状態で参292()のような行制御の
マクロを実行すると凄く時間が掛かる。
・始めExcel97は行削除に時間が掛かると思いこみ、同じことを行非表示で行えば解決
するかもしれないと考え、２９−３項のようなマクロを作成したが結果は同じだった。
・これは、Excel95・97のどちらで作成したデ−タベ−スでも同じ。
Sub 参291()
Sheets("Sheet1").Select
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.51)
.RightMargin = Application.InchesToPoints(0.23)
End With
End Sub
'
Sub 参292()
For i = 2 To cend
If Cells(i, 1) = "" Then
Exit For
End If
If InStr(1, Cells(i, 1), "-A", 1) > 0 Then
Rows(i).Select
Selection.Delete Shift:=xlUp
i = i - 1
End If
Next
End Sub
解決策：
・マクロを組む時、行制御（削除・非表示等）は"PageSetup"の前に行う。
・"PageSetup"後１度保存し再度開けばDisplayPageBreaが"False"になる。
２９−４．最終セル取得(xlCellTypeLastCell)
○●●自動記録は25項、[編集][ジャンプ][セル選択]「選択オプション」Macro4を参照の事
Sub 例294()
Selection.SpecialCells(xlCellTypeLastCell).Select
endr = ActiveCell.Row
endc = ActiveCell.Column
MsgBox "このシートの最終行：" & endr
MsgBox "このシートの最終列：" & endc
End Sub
２９−５．最終セル取得(xlLastCell)
●●●自動記録は25項、[その他][S1.最終セル選択]を参照の事
Sub 例295()
ActiveCell.SpecialCells(xlLastCell).Select
endr = ActiveCell.Row
endc = ActiveCell.Column
MsgBox "このシートの最終行：" & endr
MsgBox "このシートの最終列：" & endc
End Sub
２９−６．連続番号付加（AutoFill）
●●●自動記録は25項、[その他][S2.連続デ−タ]を参照の事
Sub 例296()
cely = ActiveCell.Row
celx = ActiveCell.Column
msg = cely & "行 " & celx & "列を１番として下方向へ番号を付けます" & Chr$(10) & _
"(指定された列の内容は番号で上書きされます）"
msg1 = MsgBox(msg, 1, "消去確認")
If msg1 = 2 Then
Exit Sub
End If
ActiveCell.SpecialCells(xlLastCell).Select
cend = ActiveCell.Row
Cells(cely, celx) = 1
Cells(cely, celx).Select
Selection.AutoFill Destination:=Range(Cells(cely, celx), Cells(cend, celx)), _
Type:=xlFillSeries
End Sub
２９−７．連続番号付加（DataSeries）
●●●自動記録は25項、[編集][フィル][連続デ−タの作成]を参照の事
Sub 例297()
cely = ActiveCell.Row
celx = ActiveCell.Column
msg = cely & "行 " & celx & "列を１番として下方向へ番号を付けます" & Chr$(10) & _
"(指定された列の内容は番号で上書きされます）"
msg1 = MsgBox(msg, 1, "消去確認")
If msg1 = 2 Then
Exit Sub
End If
ActiveCell.SpecialCells(xlLastCell).Select
cend = ActiveCell.Row
Cells(cely, celx) = 1
Range(Cells(cely, celx), Cells(cend, celx)).Select
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, _
Date:=xlDay, Step:=1, Trend:=False
End Sub
２９−８．シ−トを追加したブックにコピ−する
●●●自動記録は25項、[編集][シ−トの移動またはコピ−]を参照の事
Sub 例298()
Sheets("Sheet1").Copy
End Sub
Sub Macro2()
Cells.Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Range("A1").Select
End Sub
・後述は実際にブックを追加しているが、同じ内容を行うのであれば前述がよい。
・例298は追加したブックがアクティブにならない事があります、その場合はCopyの前に、
"ActiveWindow.WindowState = xlNormal"を入れ画面を"Normal"にしてから実行
すると上手く行きます。
２９−９．オブジェクト名とセル位置取得
○●●下記マクロはオブジェクトがどのセルにあるか取得し、別シ−トへオブジェクト
のみ貼り付ける場合等に使用できる。
Dim obg(2, 50) As String 'オブジェクト名
'
Sub 例299()
'オブジェクトチェック
i = 0
For Each ex In ActiveSheet.Shapes
obg(0, i) = ex.Name
obg(1, i) = ex.TopLeftCell.Row
obg(2, i) = ex.TopLeftCell.Column
Msg = "オブジェクト名 " & obg(0, i) & _
": Cells(" & obg(1, i) & "," & obg(2, i) & ")"
celad = MsgBox(Msg, 1, "セル位置")
If celad = 2 Then
Exit Sub
End If
i = i + 1
Next
End Sub
・下側のセルは"BottomRightCell"で取得
２９−１０．配列のデ−タを若番順に並び替え
○●●前項目でオブジェクト名とセル位置を取得しましたが、これはオブジェクト
を作成した順に取得される。もしセルの若番順にしたい場合は下記マクロ例の
ように配列を並び変える必要がある。
Dim i As Integer
Dim obg() As String 'オブジェクト名
'
Sub 例2910()
ReDim obg(2, 150)
i = 1
For Each ex In ActiveSheet.Shapes
obg(0, i) = ex.Name
obg(1, i) = ex.TopLeftCell.Row
i = i + 1
Next
'ロウの若番順に並び替え
For j = 1 To i - 1
For r = j + 1 To i - 1
If Val(obg(1, j)) > Val(obg(1, r)) Then
obgm0 = obg(0, j)
obgm1 = obg(1, j)
obg(0, j) = obg(0, r)
obg(1, j) = obg(1, r)
obg(0, r) = obgm0
obg(1, r) = obgm1
End If
Next
Next
MsgBox obg(0, 1) & " " & obg(0, 2) & " " & _
obg(0, 3) & " " & obg(0, 4) & " " & obg(0, 5) & " " & _
obg(0, 6) & " " & obg(0, 7)
End Sub
・配列の並び変えは上記の応用で簡単に出来ます。参考にして下さい。
２９−１１．グラフ名とセル位置取得
●●●マクロの内容としては29-9項と同じであるが、こちらはグラフのみが対象
Dim i As Integer
Dim obg() As String 'オブジェクト名
'
Sub 例2911()
ReDim obg(2, 150)
i = 1
For Each ex In ActiveSheet.ChartObjects
obg(0, i) = ex.Name
obg(1, i) = ex.TopLeftCell.Row
MsgBox obg(0, i) & " " & obg(1, i)
i = i + 1
Next
End Sub
２９−１２．グラフサイズの取得
●●●下記はグラフに対し縦・横のサイズ取得
Sub 例2912()
Sub bbb()
Dim obg(20) As String
'パス名取得
phn = ActiveWorkbook.Path
If phn = "" Then
MsgBox "ブックを1度保存してから実行して下さい"
End If
'gif保存
i = 1
For Each ex In ActiveSheet.ChartObjects
obg(i) = ex.Name
hei = ActiveSheet.ChartObjects(obg(i)).Chart.ChartArea.Height
wid = ActiveSheet.ChartObjects(obg(i)).Chart.ChartArea.Width
MsgBox obg(i) & " Height " & hei
MsgBox obg(i) & " Width " & wid
i = i + 1
Next
End Sub
２９−１３．現在の年齢を自動計算
○●●生年月日を入力又はこのブックを開いた時、年齢を自動計算する
下記を"ThisWorkbook"のクラスモジュ−ルへ記述
Private Sub Workbook_Open()
Worksheets("Sheet1").Activate
Selection.SpecialCells(xlCellTypeLastCell).Select
endr = ActiveCell.Row
For r = 2 To endr
Cells(r, 6) = Int((Now - Cells(r, 4)) / 365.25)
Next
End Sub
・本例はシ−トが("Sheet1")になっているので必要に応じ変更の事
下記を"Sheet1"のクラスモジュ−ルへ記述
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Application.EnableEvents = False
If Target.Column = 4 Then
r = Target.Row
If Cells(r, 4) <> "" Then
Cells(r, 6) = Int((Now - Cells(r, 4)) / 365.25)
End If
End If
Application.EnableEvents = True
End Sub
・本例は４列のデ−タが変わった時のみ計算を実行する
・"Application.EnableEvents = False"により6列へ入力した時の再帰呼び出しを
禁止してある（実行後本例のように"True"にし、イベントを有効に戻す事）
------------------------------------------------------------
上記は年齢算出のワ−クシ−ト関数があるのを知らなくて作成したが、年齢算出で
あれば特にマクロを作成しなくとも下記をセルへ記入するだけでよい。
=DATEDIF(D1,TODAY(),"y")
この関数は、Lotus 1-2-3 関数との互換性を保つために用意されており、
指定された期間内の日数、月数、または年数を返します。
２９−１４．グラフのイメ−ジ(gif)保存
○●●下記のグラフは開いているブックと同じフォルダ−へgifで保存する
Sub 例2914()
Dim obg(20) As String
'パス名取得
phn = ActiveWorkbook.Path
If phn = "" Then
MsgBox "ブックを1度保存してから実行して下さい"
Exit Sub
End If
'gif保存
i = 1
For Each ex In ActiveSheet.ChartObjects
obg(i) = ex.Name
gifname = "grf" & i & ".gif"
ActiveSheet.ChartObjects(i).Chart.Export phn & "\" & gifname
i = i + 1
Next
End Sub
２９−１５．行削除で消したグラフの削除
●●●グラフを選択し｢DEL｣キ−で消去した場合は問題ないが、グラフの表示されて
いる行を削除した場合、グラフは横線として残り(ChartObjectsとして残る）
29-14項のようにChartをマクロ制御すると問題が起きる。
下記マクロで横線として残っているグラフを消去できる。
Sub 例2915()
i = 1
For Each ex In ActiveSheet.ChartObjects
gname = ex.Name
If ex.TopLeftCell.Row = ex.BottomRightCell.Row Then
ActiveSheet.ChartObjects(gname).Delete
i = i + 1
End If
Next
・横線として残っているグラフを、ChartArea.Height、ChartArea.Widthで取得し
消去するマクロも考えたが、高さ・幅ともExcelに残っており上手くいかなかった。
２９−１６．消去グラフを排除したグラフのイメ−ジ保存
○●●横線として残っているグラフを排除してイメ−ジ(gif）保存したケ−ス
Sub 例2916()
Dim obg(20) As String
'パス名取得
phn = ActiveWorkbook.Path
If phn = "" Then
MsgBox "ブックを1度保存してから実行して下さい"
End If
'gif保存
i = 1
For Each ex In ActiveSheet.ChartObjects
obg(i) = ex.Name
If ex.TopLeftCell.Row <> ex.BottomRightCell.Row Then
gifname = "grf" & i & ".gif"
ActiveSheet.ChartObjects(i).Chart.Export phn & "\" & gifname
i = i + 1
End If
Next
End Sub
２９−１７．拡張子の取得
○○●拡張子の取得はExcel2000で追加されたInStrRev関数で容易に取得出来る。
Sub 例2917)
fff = Application.GetOpenFilename(Title:="ファイル指定")
i = InStrRev(fff, ".")
ext = Mid(fff, i)
MsgBox ext
End Sub
●●●下記はInStrRev関数を使用しないケ−ス（Excel95/97）
Sub 例2917a()
fff = Application.GetOpenFilename(Title:="ファイル指定")
i = 0: ia = 1
Do
i = InStr(ia, fff, ".")
ia = InStr(i + 1, fff, ".")
If ia = 0 Then
ext = Mid(fff, i)
End If
Loop Until ia = 0
MsgBox ext
End Sub
本例は最後に出てきた"."以降を拡張子としています。
２９−１８．ふりがなを別セルへ入力
○○●Excel2000で追加されたPHONETIC関数でふりがなを別セルへ入力できる。
Sub 例2918()
'最終行
Selection.SpecialCells(xlCellTypeLastCell).Select
endr = ActiveCell.Row
'カタカナ
Range(Cells(1, 1), Cells(endr, 1)).Select
Selection.Phonetics.CharacterType = xlKatakana
'ふりがな入力
Range(Cells(1, 2), Cells(endr, 2)).Formula = "=PHONETIC(a1)"
Range("a1").Select
End Sub
・表示をひらがなの場合は"CharacterType = xlHiragana"
・カタカナ半角の場合は"CharacterType = xlKatakanaHalf" を指定すればよい。
・Ｂ列のふりがなサイズについては、Ｂ列へフォントサイズを指定する（上例は未）
２９−１９．HTMLソ−スをワ−クシ−トへ表示（2000用）
○○●Excel2000では、HTMLファイルを拡張子txt、csvに変更してもワ−クシ−トへ
取り込めなが、下記例のように「外部デ−タの取り込み」で行えば出来ます。
Sub 例2919()
Const phn1 As String = "c:\windows\temp" '仮の保存場所
fff = Application.GetOpenFilename(Title:="HTMLタグをチェックするファイル指定")
If fff = "False" Then
MsgBox "ファイルを１個指定して下さい"
Exit Sub
End If
'拡張子
i = InStrRev(fff, ".")
ext = Mid(fff, i)
If InStr(1, ext, "htm", 1) = 0 Then
MsgBox "拡張子「html」or「htm」以外は指定出来ません"
Exit Sub
End If
FileCopy fff, phn1 & "\htmlcheck.txt"
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & phn1 & "\htmlcheck.txt", Destination:=Range("A1"))
.Name = "htmlcheck"
.RefreshStyle = xlInsertDeleteCells
.RefreshPeriod = 0
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierNone
.TextFileColumnDataTypes = Array(1)
.Refresh BackgroundQuery:=False
End With
End Sub
・"c:\windows\temp" をtxtの仮の保存場所にしてあるがシステムに合わせ変更のこと。
２９−２０．Excelバ−ジョンにより実行マクロを変える
●●●29-１項と29-19項は同じことを行っていますが、Excelバ−ジョンにより実行マクロを
変えないと目的を達成できません。マクロの実行個所が一部変わる場合は下記例がよい。
Sub 例2920()
evra = Application.Version
evrb = Val(Left(evra, 1))
If evrb = 9 Then
FileCopy fff, phn1 & "\htmlcheck.txt"
Workbooks.Add
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & phn1 & "\htmlcheck.txt", Destination:=Range("A1"))
.Name = "htmlcheck"
.RefreshStyle = xlInsertDeleteCells
.RefreshPeriod = 0
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierNone
.TextFileColumnDataTypes = Array(1)
.Refresh BackgroundQuery:=False
End With
Else
FileCopy fff, phn1 & "\engine.csv"
Workbooks.Open FileName:=phn1 & "\engine.csv"
End If
End Sub
上記の変数"evr"の値は、Excel95→7、Excel97→8、Excel2000→9、となる。
追記：バ−ジョンは数字と思っていたが、"8.0d"等がありました。上記の
ように数字変数に変えて実施した方がよい。
(29-1〜29-20)
(29-21〜29-35)
(29-36〜29-50)
(29-51〜29-61)
(29-62〜29-73)
(29-74〜 )
目次へ戻る